home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Icon 8.1 / msm-1 / rtt.sit / rttdb.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-09-19  |  40.3 KB  |  1,442 lines  |  [TEXT/MPS ]
  1. /*
  2.  * rttdb.c - routines to read, manipulate, and write the data base of
  3.  *  information about run-time routines.
  4.  */
  5.  
  6. #include "rtt.h"
  7. #include "::h:version.h"
  8.  
  9. #define DHSize 47
  10. #define MaxLine 80
  11.  
  12. /*
  13.  * prototypes for static functions.
  14.  */
  15. hidden novalue max_pre   Params((struct implement **tbl, char *pre));
  16. hidden int     name_cmp  Params((char *p1, char *p2));
  17. hidden int     op_cmp    Params((char *p1, char *p2));
  18. hidden novalue prt_dpnd  Params((FILE *db));
  19. hidden novalue prt_impls Params((FILE *db, char *sect, struct implement **tbl,
  20.                            int num, struct implement **sort_ary, int (*com)()));
  21. hidden int     prt_c_fl  Params((FILE *db, struct cfile *clst, int line_left));
  22. hidden int     put_case  Params((FILE *db, struct il_code *il));
  23. hidden novalue put_ilc   Params((FILE *db, struct il_c *ilc));
  24. hidden novalue put_inlin Params((FILE *db, struct il_code *il));
  25. hidden novalue put_ret   Params((FILE *db, struct il_c *ilc));
  26. hidden novalue put_typcd Params((FILE *db, int typcd));
  27. hidden novalue put_var   Params((FILE *db, int code, struct il_c *ilc));
  28. hidden novalue ret_flag  Params((FILE *db, int flag, int may_fthru));
  29. hidden int     set_impl  Params((struct token *name, struct implement **tbl,
  30.                            int num_impl, char *pre));
  31. hidden novalue set_prms  Params((struct implement *ptr));
  32. hidden int     src_cmp   Params((char *p1, char *p2));
  33.  
  34. static struct implement *bhash[IHSize];    /* hash area for built-in func table */
  35. static struct implement *ohash[IHSize]; /* hash area for operator table */
  36. static struct implement *khash[IHSize];    /* hash area for keyword table */
  37.  
  38. static struct srcfile *dhash[DHSize];    /* hash area for file dependencies */
  39.  
  40. static int num_fnc;        /* number of function in data base */
  41. static int num_op = 0;        /* number of operators in data base */
  42. static int num_key;        /* number of keywords in data base */
  43. static int num_src = 0;        /* number of source files in dependencies */
  44.  
  45. static char fnc_pre[2];        /* next prefix available for functions */
  46. static char op_pre[2];        /* next prefix available for operators */
  47. static char key_pre[2];        /* next prefix available for keywords */
  48.  
  49. static long min_rs;        /* min result sequence of current operation */
  50. static long max_rs;        /* max result sequence of current operation */
  51. static int rsm_rs;        /* '+' at end of result sequencce of cur. oper. */
  52.  
  53. static int newdb = 0;        /* flag: this is a new data base */
  54. struct token *comment;        /* comment associated with current operation */
  55. struct implement *cur_impl;    /* data base entry for current operation */
  56.  
  57. /*
  58.  * loaddb - load data base.
  59.  */
  60. novalue loaddb(dbname)
  61. char *dbname;
  62.    {
  63.    char *op;
  64.    struct implement *ip;
  65.    unsigned hashval;
  66.    int i;
  67.    char *srcname;
  68.    char *c_name;
  69.    struct srcfile *sfile;
  70.  
  71.  
  72.    /*
  73.     * Initialize internal data base.
  74.     */
  75.    for (i = 0; i < IHSize; i++) {
  76.        bhash[i] = NULL;   /* built-in function table */
  77.        ohash[i] = NULL;   /* operator table */
  78.        khash[i] = NULL;   /* keyword table */
  79.        }
  80.    for (i = 0; i < DHSize; i++)
  81.        dhash[i] = NULL;   /* dependency table */
  82.  
  83.    /*
  84.     * Determine if this is a new data base or an existing one.
  85.     */
  86.    if (iconx_flg || !db_open(dbname, &largeints))
  87.       newdb = 1;
  88.    else {
  89.  
  90.       /*
  91.        * Read information about built-in functions.
  92.        */
  93.       num_fnc = db_tbl("functions", bhash);
  94.  
  95.       /*
  96.        * Read information about operators.
  97.        */
  98.       db_chstr("", "operators");    /* verify and skip "operators" */
  99.  
  100.       while ((op = db_string()) != NULL) {
  101.          /*
  102.           * Read header information for the operator.
  103.            */
  104.          if ((ip = db_impl('O')) == NULL)
  105.             db_err2(1, "no implementation information for operator", op);
  106.          ip->op = op;
  107.  
  108.          /*
  109.           * Read the descriptive comment and in-line code for the operator,
  110.           *  then put the entry in the hash table.
  111.           */
  112.          db_code(ip);
  113.          hashval = (int)IHasher(op);
  114.          ip->blink = ohash[hashval];
  115.          ohash[hashval] = ip;
  116.          db_chstr("", "end");         /* verify and skip "end" */
  117.          ++num_op;
  118.          }
  119.       db_chstr("", "endsect");       /* verify and skip "endsect" */
  120.  
  121.       /*
  122.        * Read information about keywords.
  123.        */
  124.       num_key = db_tbl("keywords", khash);
  125.  
  126.       /*
  127.        * Read C file/source dependency information.
  128.        */
  129.       db_chstr("", "dependencies");  /* verify and skip "dependencies" */
  130.  
  131.       while ((srcname = db_string()) != NULL) {
  132.          sfile = src_lkup(srcname);
  133.          while ((c_name = db_string()) != NULL)
  134.             add_dpnd(sfile, c_name);
  135.          db_chstr("", "end");         /* verify and skip "end" */
  136.          }
  137.       db_chstr("", "endsect");        /* verify and skip "endsect" */
  138.  
  139.       db_close();
  140.       }
  141.  
  142.    /*
  143.     * Determine the next available operation prefixes by finding the
  144.     *  maximum prefixes currently in use.
  145.     */
  146.    max_pre(bhash, fnc_pre);
  147.    max_pre(ohash, op_pre);
  148.    max_pre(khash, key_pre);
  149.    }
  150.  
  151. /*
  152.  * max_pre - find the maximum prefix in an implemetation table and set the
  153.  *  prefix array to the next value.
  154.  */
  155. static novalue max_pre(tbl, pre)
  156. struct implement **tbl;
  157. char *pre;
  158.    {
  159.    register struct implement *ptr;
  160.    unsigned hashval;
  161.    int empty = 1;
  162.    char dmy_pre[2];
  163.  
  164.    pre[0] = '0';
  165.    pre[1] = '0';
  166.    for (hashval = 0; hashval < IHSize; ++hashval) 
  167.       for (ptr = tbl[hashval]; ptr != NULL; ptr = ptr->blink) {
  168.          empty = 0;
  169.          /*
  170.           * Determine if this prefix is larger than any found so far.
  171.           */
  172.          if (cmp_pre(ptr->prefix, pre) > 0) {
  173.             pre[0] = ptr->prefix[0];
  174.             pre[1] = ptr->prefix[1];
  175.             }
  176.          }
  177.    if (!empty)
  178.       nxt_pre(dmy_pre, pre, 2);
  179.    }
  180.  
  181.  
  182. /*
  183.  * src_lkup - return pointer to dependency information for the given
  184.  *   source file.
  185.  */
  186. struct srcfile *src_lkup(srcname)
  187. char *srcname;
  188.    {
  189.    unsigned hashval;
  190.    struct srcfile *sfile;
  191.  
  192.    /*
  193.     * See if the source file is already in the dependancy section of
  194.     *  the data base.
  195.     */
  196.    hashval = (unsigned)srcname % DHSize;
  197.    for (sfile = dhash[hashval]; sfile != NULL && sfile->name != srcname;
  198.         sfile = sfile->next)
  199.       ;
  200.  
  201.    /*
  202.     * If an entry for the source file was not found, create one.
  203.     */
  204.    if (sfile == NULL) {
  205.       sfile = NewStruct(srcfile);
  206.       sfile->name = srcname;
  207.       sfile->dependents = NULL;
  208.       sfile->next = dhash[hashval];
  209.       dhash[hashval] = sfile;
  210.       ++num_src;
  211.       }
  212.    return sfile;
  213.    }
  214.  
  215. /*
  216.  * add_dpnd - add the given source/dependency relation to the dependency
  217.  *   table.
  218.  */
  219. novalue add_dpnd(sfile, c_name)
  220. struct srcfile *sfile;
  221. char *c_name;
  222.    {
  223.    struct cfile *cf;
  224.  
  225.    cf = NewStruct(cfile);
  226.    cf->name = c_name;
  227.    cf->next = sfile->dependents;
  228.    sfile->dependents = cf;
  229.    }
  230.  
  231. /*
  232.  * clr_dpnd - delete all dependencies for the given source file.
  233.  */
  234. novalue clr_dpnd(srcname)
  235. char *srcname;
  236.    {
  237.    src_lkup(srcname)->dependents = NULL;
  238.    }
  239.  
  240. /*
  241.  * dumpdb - write the updated data base.
  242.  */
  243. novalue dumpdb(dbname)
  244. char *dbname;
  245.    {
  246. #ifdef Rttx
  247.    fprintf(stdout, "rtt was compiled to only support the intepreter, use -x\n");
  248.    exit(ErrorExit);
  249. #else                    /* Rttx */
  250.    FILE *db;
  251.    struct implement **sort_ary;
  252.    int ary_sz;
  253.    int i;
  254.  
  255.    db = fopen(dbname, "w");
  256.    if (db == NULL)
  257.       err2("cannot open data base for output:", dbname);
  258.    if(newdb)
  259.       fprintf(stdout, "creating new data base: %s\n", dbname);
  260.  
  261.    /*
  262.     * The data base starts with a version number associated with this
  263.     *   version of rtt and an indication of whether LargeInts was
  264.     *   defined during the build.
  265.     */
  266.    fprintf(db, "%s %s\n\n", DVersion, largeints);
  267.  
  268.    fprintf(db, "\ntypes\n\n");          /* start of type code section */
  269.    for (i = 0; i < num_typs; ++i)
  270.       fprintf(db, "   T%d: %s\n", i, icontypes[i].id);
  271.    fprintf(db, "\n$endsect\n\n");       /* end of section for type codes */
  272.  
  273.    fprintf(db, "\ncomponents\n\n");     /* start of component code section */
  274.    for (i = 0; i < num_cmpnts; ++i)
  275.       fprintf(db, "   C%d: %s\n", i, typecompnt[i].id);
  276.    fprintf(db, "\n$endsect\n\n");       /* end of section for component codes */
  277.  
  278.    /*
  279.     * Allocate an array for sorting operation entries. It must be
  280.     *   large enough to hold functions, operators, or keywords.
  281.     */
  282.    ary_sz = Max(num_fnc, num_op);
  283.    ary_sz = Max(ary_sz, num_key);
  284.    if (ary_sz > 0)
  285.       sort_ary = (struct implement**)alloc((unsigned int)(ary_sz *
  286.            sizeof(struct implement*)));
  287.    else
  288.       sort_ary = NULL;
  289.  
  290.    /*
  291.     * Sort and print to the data base the enties for each of the
  292.     *   three operation sections.
  293.     */
  294.    prt_impls(db, "functions", bhash, num_fnc, sort_ary, name_cmp);
  295.    prt_impls(db, "\noperators", ohash, num_op, sort_ary, op_cmp);
  296.    prt_impls(db, "\nkeywords", khash, num_key, sort_ary, name_cmp);
  297.    if (ary_sz > 0)
  298.       free((char *)sort_ary);
  299.  
  300.    /*
  301.     * Print the dependancy information to the data base.
  302.     */
  303.    prt_dpnd(db);
  304.    if (fclose(db) != 0)
  305.      err2("cannot close ", dbname);
  306. #endif                    /* Rttx */
  307.    }
  308.  
  309. #ifndef Rttx
  310. /*
  311.  * prt_impl - sort and print to the data base the enties from one
  312.  *   of the operation tables.
  313.  */
  314. static novalue prt_impls(db, sect, tbl, num, sort_ary, cmp)
  315. FILE *db;
  316. char *sect;
  317. struct implement **tbl;
  318. int num;
  319. struct implement **sort_ary;
  320. int (*cmp)();
  321.    {
  322.    int i;
  323.    int j;
  324.    unsigned hashval;
  325.    struct implement *ip;
  326.  
  327.    /*
  328.     * Each operation section begins with the section name.
  329.     */
  330.    fprintf(db, "%s\n\n", sect);
  331.  
  332.    /*
  333.     * Sort the table entries before printing.
  334.     */
  335.    if (num > 0) {
  336.       i = 0;
  337.       for (hashval = 0; hashval < IHSize; ++hashval)
  338.          for (ip = tbl[hashval]; ip != NULL; ip = ip->blink)
  339.             sort_ary[i++] = ip;
  340.       qsort((char *)sort_ary, num, sizeof(struct implement *), cmp);
  341.       }
  342.  
  343.    /*
  344.     * Output each entry to the data base.
  345.     */
  346.    for (i = 0; i < num; ++i) {
  347.       ip = sort_ary[i];
  348.  
  349.       /*
  350.        * Operators have operator symbols.
  351.        */
  352.       if (ip->op != NULL)
  353.          fprintf(db, "%s\t", ip->op);
  354.  
  355.       /*
  356.        * Print the operation name, the unique prefix used to generate
  357.        *   C function names, and the number of parameters to the operation.
  358.        */
  359.       fprintf(db, "%s\t%c%c %d(", ip->name, ip->prefix[0], ip->prefix[1],
  360.          ip->nargs);
  361.  
  362.       /*
  363.        * For each parameter, write and indication of whether a dereferenced
  364.        *   value, 'd', and/or and undereferenced value, 'u', is needed.
  365.        */
  366.       for (j = 0; j < ip->nargs; ++j) {
  367.          if (j > 0)
  368.             fprintf(db, ",");
  369.          if (ip->arg_flgs[j] & RtParm)
  370.             fprintf(db, "u");
  371.          if (ip->arg_flgs[j] & DrfPrm)
  372.             fprintf(db, "d");
  373.          }
  374.  
  375.       /*
  376.        * Indicate if the last parameter represents the tail of a
  377.        *   variable length argument list.
  378.        */
  379.       if (ip->nargs > 0 && ip->arg_flgs[ip->nargs - 1] & VarPrm)
  380.          fprintf(db, "v");
  381.       fprintf(db, ")\t{");
  382.  
  383.       /*
  384.        * Print the min and max result sequence length.
  385.        */
  386.       if (ip->min_result != NoRsltSeq) {
  387.          fprintf(db, "%ld,", ip->min_result);
  388.          if (ip->max_result == UnbndSeq)
  389.             fprintf(db, "*");
  390.          else
  391.             fprintf(db, "%ld", ip->max_result);
  392.          if (ip->resume)
  393.             fprintf(db, "+");
  394.          }
  395.       fprintf(db, "} ");
  396.  
  397.       /*
  398.        * Print the return/suspend/fail/fall-through flag and an indication
  399.        *   of whether the operation explicitly uses the result location
  400.        *   (as opposed to an implicit use via return or suspend).
  401.        */
  402.       ret_flag(db, ip->ret_flag, 0);
  403.       if (ip->use_rslt)
  404.          fprintf(db, "t ");
  405.       else
  406.          fprintf(db, "f ");
  407.  
  408.       /*
  409.        * Print the descriptive comment associated with the operation.
  410.        */
  411.       fprintf(db, "\n\"%s\"\n", ip->comment);
  412.  
  413.       /*
  414.        * Print information about tended declarations from the declare
  415.        *  statement. The number of tended variables is printed followed
  416.        *  by an entry for each variable. Each entry consists of the
  417.        *  type of the declaration
  418.        * 
  419.        *     struct descrip  -> desc
  420.        *     char *          -> str
  421.        *     struct b_xxx *  -> blkptr b_xxx
  422.        *     union block *   -> blkptr *
  423.        *
  424.        *  followed by the C code for the initializer (nil indicates none).
  425.        */
  426.       fprintf(db, "%d ", ip->ntnds);
  427.       for (j = 0; j < ip->ntnds; ++j) {
  428.          switch (ip->tnds[j].var_type) {
  429.             case TndDesc:
  430.                fprintf(db, "desc ");
  431.                break;
  432.             case TndStr:
  433.                fprintf(db, "str ");
  434.                break;
  435.             case TndBlk:
  436.                fprintf(db, "blkptr ");
  437.                if (ip->tnds[j].blk_name == NULL)
  438.                   fprintf(db, "* ");
  439.                else
  440.                   fprintf(db, "%s ", ip->tnds[j].blk_name);
  441.                break;
  442.             }
  443.          put_ilc(db, ip->tnds[j].init);
  444.          }
  445.  
  446.       /*
  447.        * Print information about non-tended declarations from the declare
  448.        *  statement. The number of variables is printed followed by an
  449.        *  entry for each variable. Each entry consists of the variable
  450.        *  name followed by the complete C code for the declaration.
  451.        */
  452.       fprintf(db, "\n%d ", ip->nvars);
  453.       for (j = 0; j < ip->nvars; ++j) {
  454.          fprintf(db, "%s ", ip->vars[j].name);
  455.          put_ilc(db, ip->vars[j].dcl);
  456.          }
  457.       fprintf(db, "\n");
  458.  
  459.       /*
  460.        * Output the "executable" code (includes abstract code) for the
  461.        *   operation.
  462.        */
  463.       put_inlin(db, ip->in_line);
  464.       fprintf(db, "\n$end\n\n");    /* end of operation entry */
  465.       }
  466.    fprintf(db, "$endsect\n\n");     /* end of section for operation type */
  467.    }
  468.  
  469. /*
  470.  * put_inlin - put in-line code into the data base file. This is the
  471.  *   code used by iconc to perform type infernence for the operation
  472.  *   and to generate a tailored version of the operation.
  473.  */
  474. static novalue put_inlin(db, il)
  475. FILE *db;
  476. struct il_code *il;
  477.    {
  478.    int i;
  479.    int num_cases;
  480.    int indx;
  481.  
  482.    /*
  483.     * RTL statements are handled by this function. Other functions
  484.     *  are called for C code.
  485.     */
  486.    if (il == NULL) {
  487.       fprintf(db, "nil ");
  488.       return;
  489.       }
  490.  
  491.    switch (il->il_type) {
  492.       case IL_Const:
  493.          /*
  494.           * Constant keyword.
  495.           */
  496.          fprintf(db, "const ");
  497.          put_typcd(db, il->u[0].n);              /* type  code */
  498.          fprintf(db, "%s ", il->u[1].s);         /* literal */
  499.          break;
  500.       case IL_If1:
  501.          /*
  502.           * if-then statment.
  503.           */
  504.          fprintf(db, "if1 ");
  505.          put_inlin(db, il->u[0].fld);            /* condition */
  506.          fprintf(db, "\n");
  507.          put_inlin(db, il->u[1].fld);            /* then clause */
  508.          break;
  509.       case IL_If2:
  510.          /*
  511.           * if-then-else statment.
  512.           */
  513.          fprintf(db, "if2 ");
  514.          put_inlin(db, il->u[0].fld);            /* condition */
  515.          fprintf(db, "\n");
  516.          put_inlin(db, il->u[1].fld);            /* then clause */
  517.          fprintf(db, "\n");
  518.          put_inlin(db, il->u[2].fld);            /* else clause */
  519.          break;
  520.       case IL_Tcase1:
  521.          /*
  522.           * type_case statement with no default clause.
  523.           */
  524.          fprintf(db, "tcase1 ");
  525.          put_case(db, il);
  526.          break;
  527.       case IL_Tcase2:
  528.          /*
  529.           * type_case statement with a default clause.
  530.           */
  531.          fprintf(db, "tcase2 ");
  532.          indx = put_case(db, il);
  533.          fprintf(db, "\n");
  534.          put_inlin(db, il->u[indx].fld);         /* default */
  535.          break;
  536.       case IL_Lcase:
  537.          /*
  538.           * len_case statement.
  539.           */
  540.          fprintf(db, "lcase ");
  541.          num_cases = il->u[0].n;
  542.          fprintf(db, "%d ", num_cases);
  543.          indx = 1;
  544.          for (i = 0; i < num_cases; ++i) {
  545.             fprintf(db, "\n%d ", il->u[indx++].n);    /* selection number */
  546.             put_inlin(db, il->u[indx++].fld);        /* action */
  547.             }
  548.          fprintf(db, "\n");
  549.          put_inlin(db, il->u[indx].fld);             /* default */
  550.          break;
  551.       case IL_Acase:
  552.          /*
  553.           * arith_case statement.
  554.           */
  555.          fprintf(db, "acase ");
  556.          put_inlin(db, il->u[0].fld);               /* first variable */
  557.          put_inlin(db, il->u[1].fld);               /* second variable */
  558.          fprintf(db, "\n");
  559.          put_inlin(db, il->u[2].fld);               /* C_integer action */
  560.          fprintf(db, "\n");
  561.          put_inlin(db, il->u[3].fld);               /* integer action */
  562.          fprintf(db, "\n");
  563.          put_inlin(db, il->u[4].fld);               /* C_double action */
  564.          break;
  565.       case IL_Err1:
  566.          /*
  567.           * runerr with no value argument.
  568.           */
  569.          fprintf(db, "runerr1 ");
  570.          fprintf(db, "%d ", il->u[0].n);      /* error number */
  571.          break;
  572.       case IL_Err2:
  573.          /*
  574.           * runerr with a value argument.
  575.           */
  576.          fprintf(db, "runerr2 ");
  577.          fprintf(db, "%d ", il->u[0].n);      /* error number */
  578.          put_inlin(db, il->u[1].fld);          /* variable */
  579.          break;
  580.       case IL_Lst:
  581.          /*
  582.           * "glue" to string statements together.
  583.           */
  584.          fprintf(db, "lst ");
  585.          put_inlin(db, il->u[0].fld);
  586.          fprintf(db, "\n");
  587.          put_inlin(db, il->u[1].fld);
  588.          break;
  589.       case IL_Bang:
  590.          /*
  591.           * ! operator from type checking.
  592.           */
  593.          fprintf(db, "! ");
  594.          put_inlin(db, il->u[0].fld);
  595.          break;
  596.       case IL_And:
  597.          /*
  598.           * && operator from type checking.
  599.           */
  600.          fprintf(db, "&& ");
  601.          put_inlin(db, il->u[0].fld);
  602.          put_inlin(db, il->u[1].fld);
  603.          break;
  604.       case IL_Cnv1:
  605.          /*
  606.           * cnv:<dest-type>(<source>)
  607.           */
  608.          fprintf(db, "cnv1 ");
  609.          put_typcd(db, il->u[0].n);      /* type code */
  610.          put_inlin(db, il->u[1].fld);    /* source */
  611.          break;
  612.       case IL_Cnv2:
  613.          /*
  614.           * cnv:<dest-type>(<source>,<destination>)
  615.           */
  616.          fprintf(db, "cnv2 ");
  617.          put_typcd(db, il->u[0].n);      /* type code */
  618.          put_inlin(db, il->u[1].fld);    /* source */
  619.          put_ilc(db, il->u[2].c_cd);     /* destination */
  620.          break;
  621.       case IL_Def1:
  622.          /*
  623.           * def:<dest-type>(<source>,<default-value>)
  624.           */
  625.          fprintf(db, "def1 ");
  626.          put_typcd(db, il->u[0].n);      /* type code */
  627.          put_inlin(db, il->u[1].fld);    /* source */
  628.          put_ilc(db, il->u[2].c_cd);     /* default value */
  629.          break;
  630.       case IL_Def2:
  631.          /*
  632.           * def:<dest-type>(<source>,<default-value>,<destination>)
  633.           */
  634.          fprintf(db, "def2 ");
  635.          put_typcd(db, il->u[0].n);      /* type code */
  636.          put_inlin(db, il->u[1].fld);    /* source */
  637.          put_ilc(db, il->u[2].c_cd);     /* default value */
  638.          put_ilc(db, il->u[3].c_cd);     /* destination */
  639.          break;
  640.       case IL_Is:
  641.          /*
  642.           * is:<type-name>(<variable>)
  643.           */
  644.          fprintf(db, "is ");
  645.          put_typcd(db, il->u[0].n);      /* type code */
  646.          put_inlin(db, il->u[1].fld);    /* variable */
  647.          break;
  648.       case IL_Var:
  649.          /*
  650.           * A variable.
  651.           */
  652.          fprintf(db, "%d ", il->u[0].n);    /* symbol table index */
  653.          break;
  654.       case IL_Subscr:
  655.          /*
  656.           * A subscripted variable.
  657.           */
  658.          fprintf(db, "[ ");
  659.          fprintf(db, "%d ", il->u[0].n);    /* symbol table index */
  660.          fprintf(db, "%d ", il->u[1].n);    /* subscripting index */
  661.          break;
  662.       case IL_Block:
  663.          /*
  664.           * A block of in-line code. 
  665.           */
  666.          fprintf(db, "block ");
  667.          if (il->u[0].n)
  668.             fprintf(db, "t ");              /* execution can fall through */
  669.          else
  670.             fprintf(db, "_ ");              /* execution cannot fall through */
  671.           /*
  672.            * Output a symbol table of tended variables.
  673.            */
  674.          fprintf(db, "%d ", il->u[1].n);    /* number of local tended */
  675.          for (i = 2; i - 2 < il->u[1].n; ++i)
  676.              switch (il->u[i].n) {
  677.                 case TndDesc:
  678.                    fprintf(db, "desc ");
  679.                    break;
  680.                 case TndStr:
  681.                    fprintf(db, "str ");
  682.                    break;
  683.                 case TndBlk:
  684.                    fprintf(db, "blkptr ");
  685.                    break;
  686.                 }
  687.          put_ilc(db, il->u[i].c_cd);         /* body of block */
  688.          break;
  689.       case IL_Call:
  690.          /*
  691.           * A call to a body function.
  692.           */
  693.          fprintf(db, "call ");
  694.  
  695.          /*
  696.           * Each body function has a 3rd prefix character to distingish
  697.           *  it from other functions for the operation.
  698.           */
  699.          fprintf(db, "%c ", (char)il->u[1].n);
  700.  
  701.          /*
  702.           * A body function that would only return one possible signal
  703.           *   need return none. In which case, it can directly return a
  704.           *   C integer or double directly rather than using a result
  705.           *   descriptor location. Indicate what it does.
  706.           */
  707.          switch (il->u[2].n) {
  708.             case RetInt:
  709.                fprintf(db, "i ");  /* directly return integer */
  710.                break;
  711.             case RetDbl:
  712.                fprintf(db, "d ");  /* directly return double */
  713.                break;
  714.             case RetNoVal:
  715.                fprintf(db, "n ");  /* return nothing directly */
  716.                break;
  717.             case RetSig:
  718.                fprintf(db, "s ");  /* return a signal */
  719.                break;
  720.             }
  721.  
  722.          /*
  723.           * Output the return/suspend/fail/fall-through flag.
  724.           */
  725.          ret_flag(db, il->u[3].n, 1);
  726.  
  727.          /*
  728.           * Indicate whether the body function expects to have
  729.           *   an explicit result location passed to it.
  730.           */
  731.          if (il->u[4].n)
  732.             fprintf(db, "t ");
  733.          else
  734.             fprintf(db, "f ");
  735.  
  736.          fprintf(db, "%d ", il->u[5].n);    /* num string bufs */
  737.          fprintf(db, "%d ", il->u[6].n);    /* num cset bufs */
  738.          i = il->u[7].n;
  739.          fprintf(db, "%d ", i);             /* num args */
  740.          indx = 8;
  741.          /*
  742.           * output prototype paramater declarations and actual arguments.
  743.           */
  744.          i *= 2;
  745.          while (i--)
  746.             put_ilc(db, il->u[indx++].c_cd);
  747.          break;
  748.       case IL_Abstr:
  749.          /*
  750.           * Abstract type computation.
  751.           */
  752.          fprintf(db, "abstr ");
  753.          put_inlin(db, il->u[0].fld);    /* side effects */
  754.          put_inlin(db, il->u[1].fld);    /* return type */
  755.          break;
  756.       case IL_VarTyp:
  757.          /*
  758.           * type(<parameter>)
  759.           */
  760.          fprintf(db, "vartyp ");
  761.          put_inlin(db, il->u[0].fld);    /* variable */
  762.          break;
  763.       case IL_Store:
  764.          /*
  765.           * store[<type>]
  766.           */
  767.          fprintf(db, "store ");
  768.          put_inlin(db, il->u[0].fld);    /* type to be "dereferenced "*/
  769.          break;
  770.       case IL_Compnt:
  771.          /*
  772.           * <type>.<component>
  773.           */
  774.          fprintf(db, ". ");
  775.          put_inlin(db, il->u[0].fld);    /* type */
  776.          if (il->u[1].n == CM_Fields)
  777.              fprintf(db, "f ");          /* special case record fields */
  778.          else
  779.              fprintf(db, "C%d ", (int)il->u[1].n); /* component table index */
  780.          break;
  781.       case IL_TpAsgn:
  782.          /*
  783.           * store[<variable-type>] = <value-type>
  784.           */
  785.          fprintf(db, "= ");
  786.          put_inlin(db, il->u[0].fld);    /* variable type */
  787.          put_inlin(db, il->u[1].fld);    /* value type */
  788.          break;
  789.       case IL_Union:
  790.          /*
  791.           * <type 1> ++ <type 2>
  792.           */
  793.          fprintf(db, "++ ");
  794.          put_inlin(db, il->u[0].fld);
  795.          put_inlin(db, il->u[1].fld);
  796.          break;
  797.       case IL_Inter:
  798.          /*
  799.           * <type 1> ** <type 2>
  800.           */
  801.          fprintf(db, "** ");
  802.          put_inlin(db, il->u[0].fld);
  803.          put_inlin(db, il->u[1].fld);
  804.          break;
  805.       case IL_New:
  806.          /*
  807.           * new <type-name>(<type 1> , ...)
  808.           */
  809.          fprintf(db, "new ");
  810.          put_typcd(db, il->u[0].n);      /* type code */
  811.          i = il->u[1].n;
  812.          fprintf(db, "%d ", i);          /* num args */
  813.          indx = 2;
  814.          while (i--)
  815.             put_inlin(db, il->u[indx++].fld);
  816.          break;
  817.       case IL_IcnTyp:
  818.          /*
  819.           * <type-name>
  820.           */
  821.          fprintf(db, "typ ");
  822.          put_typcd(db, il->u[0].n);      /* type code */
  823.          break;
  824.       }
  825.    }
  826.  
  827. /*
  828.  * put_case - put the cases of a type_case statement into the data base file.
  829.  */
  830. static int put_case(db, il)
  831. FILE *db;
  832. struct il_code *il;
  833.    {
  834.    int *typ_vect;
  835.    int i, j;
  836.    int num_cases;
  837.    int num_types;
  838.    int indx;
  839.  
  840.    put_inlin(db, il->u[0].fld);               /* expression being checked */
  841.    num_cases = il->u[1].n;                    /* number of cases */
  842.    fprintf(db, "%d ", num_cases);
  843.    indx = 2;
  844.    for (i = 0; i < num_cases; ++i) {
  845.       num_types = il->u[indx++].n;             /* number of types in case */
  846.       fprintf(db, "\n%d ", num_types);
  847.       typ_vect = il->u[indx++].vect;          /* vector of type codes */
  848.       for (j = 0; j < num_types; ++j)
  849.          put_typcd(db, typ_vect[j]);          /* type code */
  850.       put_inlin(db, il->u[indx++].fld);       /* action */
  851.       }
  852.    return indx;
  853.    }
  854.  
  855. /*
  856.  * put_typcd - convert a numeric type code into an alpha type code and
  857.  *  put it in the data base file.
  858.  */
  859. static novalue put_typcd(db, typcd)
  860. FILE *db;
  861. int typcd;
  862.    {
  863.    if (typcd >= 0)
  864.       fprintf(db, "T%d ", typcd);
  865.    else {
  866.       switch (typcd) {
  867.          case TypAny:
  868.             fprintf(db, "a ");       /* any_value */
  869.             break;
  870.          case TypEmpty:
  871.             fprintf(db, "e ");       /* empty_type */
  872.             break;
  873.          case TypVar:
  874.             fprintf(db, "v ");       /* variable */
  875.             break;
  876.          case TypCInt:
  877.             fprintf(db, "ci ");    /* C_integer */
  878.             break;
  879.          case TypCDbl:
  880.             fprintf(db, "cd ");    /* C_double */
  881.             break;
  882.          case TypCStr:
  883.             fprintf(db, "cs ");    /* C_string */
  884.             break;
  885.          case TypEInt:
  886.             fprintf(db, "ei ");    /* (exact)integer) */
  887.             break;
  888.          case TypECInt:
  889.             fprintf(db, "eci ");   /* (exact)C_integer */
  890.             break;
  891.          case TypTStr:
  892.             fprintf(db, "ts ");    /* tmp_string */
  893.             break;
  894.          case TypTCset:
  895.             fprintf(db, "tc ");    /* tmp_cset */
  896.             break;
  897.          case RetDesc:
  898.             fprintf(db, "d ");     /* plain descriptor on return/suspend */
  899.             break;
  900.          case RetNVar:
  901.             fprintf(db, "nv ");    /* named_var */
  902.             break;
  903.          case RetSVar:
  904.             fprintf(db, "sv ");    /* struct_var */
  905.             break;
  906.          case RetNone:
  907.             fprintf(db, "rn ");   /* preset result location on return/suspend */
  908.             break;
  909.          }
  910.       }
  911.    }
  912.  
  913. /*
  914.  * put_ilc - put in-line C code in the data base file.
  915.  */
  916. static novalue put_ilc(db, ilc)
  917. FILE *db;
  918. struct il_c *ilc;
  919.    {
  920.    /*
  921.     * In-line C code is either "nil" or code bracketed by $c $e.
  922.     *   The bracketed code consists of text for C code plus special
  923.     *   constructs starting with $. Control structures have been
  924.     *   translated into gotos in the form of special constructs
  925.     *   (note that case statements are not supported in in-line code).
  926.     */
  927.    if (ilc == NULL) {
  928.       fprintf(db, "nil ");
  929.       return;
  930.       }
  931.    fprintf(db, "$c ");
  932.    while (ilc != NULL) {
  933.       switch(ilc->il_c_type) {
  934.          case ILC_Ref:
  935.             put_var(db, 'r', ilc);   /* non-modifying reference to variable */
  936.             break;
  937.          case ILC_Mod:
  938.             put_var(db, 'm', ilc);   /* modifying reference to variable */
  939.             break;
  940.          case ILC_Tend:
  941.             put_var(db, 't', ilc);   /* variable declared tended */
  942.             break;
  943.          case ILC_SBuf:
  944.             fprintf(db, "$sb ");     /* string buffer for tmp_string */
  945.             break;
  946.          case ILC_CBuf:
  947.             fprintf(db, "$cb ");     /* cset buffer for tmp_cset */
  948.             break;
  949.          case ILC_Ret:
  950.             fprintf(db, "$ret ");    /* return statement */
  951.             put_ret(db, ilc);
  952.             break;
  953.          case ILC_Susp:
  954.             fprintf(db, "$susp ");   /* suspend statement */
  955.             put_ret(db, ilc);
  956.             break;
  957.          case ILC_Fail:
  958.             fprintf(db, "$fail ");   /* fail statement */
  959.             break;
  960.          case ILC_EFail:
  961.             fprintf(db, "$efail ");  /* errorfail statement */
  962.             break;
  963.          case ILC_Goto:
  964.             fprintf(db, "$goto %d ", ilc->n);  /* goto label */
  965.             break;
  966.          case ILC_CGto:
  967.             fprintf(db, "$cgoto ");            /* conditional goto */
  968.             put_ilc(db, ilc->code[0]);         /* condition (with $c $e) */
  969.             fprintf(db, "%d ", ilc->n);        /* label */
  970.             break;
  971.          case ILC_Lbl:
  972.             fprintf(db, "$lbl %d ", ilc->n);   /* label */
  973.             break;
  974.          case ILC_LBrc:
  975.             fprintf(db, "${ ");                /* start of C block with dcls */
  976.             break;
  977.          case ILC_RBrc:
  978.             fprintf(db, "$} ");                /* end of C block with dcls */
  979.             break;
  980.          case ILC_Str:
  981.             fprintf(db, "%s", ilc->s);         /* C code as plain text */
  982.             break;
  983.          }
  984.       ilc = ilc->next;
  985.       }
  986.    fprintf(db, " $e ");
  987.    }
  988.  
  989. /*
  990.  * put_var - output in-line C code for a variable.
  991.  */
  992. static novalue put_var(db, code, ilc)
  993. FILE *db;
  994. int code;
  995. struct il_c *ilc;
  996.    {
  997.    fprintf(db, "$%c", code);  /* 'r': non-mod ref, 'm': mod ref, 't': tended */
  998.    if (ilc->s != NULL)
  999.       fprintf(db, "%s", ilc->s);  /* access into descriptor */
  1000.    if (ilc->n == RsltIndx)
  1001.       fprintf(db, "r ");          /* this is "result" */
  1002.    else
  1003.       fprintf(db, "%d ", ilc->n); /* offset into a symbol table */
  1004.    }
  1005.  
  1006. /*
  1007.  * ret_flag - put a return/suspend/fail/fall-through flag in the data base
  1008.  *  file.
  1009.  */
  1010. static novalue ret_flag(db, flag, may_fthru)
  1011. FILE *db;
  1012. int flag;
  1013. int may_fthru;
  1014.    {
  1015.    if (flag & DoesFail)
  1016.       fprintf(db, "f");      /* can fail */
  1017.    else
  1018.       fprintf(db, "_");      /* cannot fail */
  1019.    if (flag & DoesRet)
  1020.       fprintf(db, "r");      /* can return */
  1021.    else
  1022.       fprintf(db, "_");      /* cannot return */
  1023.    if (flag & DoesSusp)
  1024.       fprintf(db, "s");      /* can suspend */
  1025.    else
  1026.       fprintf(db, "_");      /* cannot suspend */
  1027.    if (flag & DoesEFail)
  1028.       fprintf(db, "e");      /* can do error conversion */
  1029.    else
  1030.       fprintf(db, "_");      /* cannot do error conversion */
  1031.    if (may_fthru)            /* body functions only: */
  1032.       if (flag & DoesFThru)
  1033.          fprintf(db, "t");      /* can fall through */
  1034.       else
  1035.          fprintf(db, "_");      /* cannot fall through */
  1036.   fprintf(db, " ");
  1037.   }
  1038.  
  1039. /*
  1040.  * put_ret - put the body of a return/suspend statement in the data base.
  1041.  */
  1042. static novalue put_ret(db, ilc)
  1043. FILE *db;
  1044. struct il_c *ilc;
  1045.    {
  1046.    int i;
  1047.  
  1048.    /*
  1049.     * Output the type of descriptor constructor on the return/suspend,
  1050.     *  then output the the number of arguments to the constructor, and
  1051.     *  the arguments themselves.
  1052.     */
  1053.    put_typcd(db, ilc->n);
  1054.    for (i = 0; i < 3 && ilc->code[i] != NULL; ++i)
  1055.        ;
  1056.    fprintf(db, "%d ", i);
  1057.    for (i = 0; i < 3 && ilc->code[i] != NULL; ++i)
  1058.        put_ilc(db, ilc->code[i]);
  1059.    }
  1060.  
  1061. /*
  1062.  * name_cmp - compare implementation structs by name; function used as
  1063.  *  an argument to qsort().
  1064.  */
  1065. static int name_cmp(p1, p2)
  1066. char *p1;
  1067. char *p2;
  1068.    {
  1069.    register struct implement *ip1;
  1070.    register struct implement *ip2;
  1071.  
  1072.    ip1 = *(struct implement **)p1;
  1073.    ip2 = *(struct implement **)p2;
  1074.    return strcmp(ip1->name, ip2->name);
  1075.    }
  1076.  
  1077. /*
  1078.  * op_cmp - compare implementation structs by operator and number of args;
  1079.  *   function used as an argument to qsort().
  1080.  */
  1081. static int op_cmp(p1, p2)
  1082. char *p1;
  1083. char *p2;
  1084.    {
  1085.    register int cmp;
  1086.    register struct implement *ip1;
  1087.    register struct implement *ip2;
  1088.  
  1089.    ip1 = *(struct implement **)p1;
  1090.    ip2 = *(struct implement **)p2;
  1091.  
  1092.    cmp = strcmp(ip1->op, ip2->op);
  1093.    if (cmp == 0)
  1094.       return ip1->nargs - ip2->nargs;
  1095.    else
  1096.       return cmp;
  1097.    }
  1098.  
  1099. /*
  1100.  * prt_dpnd - print dependency information to the data base.
  1101.  */
  1102. static novalue prt_dpnd(db)
  1103. FILE *db;
  1104.    {
  1105.    struct srcfile **sort_ary;
  1106.    struct srcfile *sfile;
  1107.    unsigned hashval;
  1108.    int line_left;
  1109.    int num;
  1110.    int i;
  1111.  
  1112.    fprintf(db, "\ndependencies\n\n");  /* start of dependency section */
  1113.  
  1114.    /*
  1115.     * sort the dependency information by source file name.
  1116.     */
  1117.    num = 0;
  1118.    if (num_src > 0) {
  1119.       sort_ary = (struct srcfile **)alloc((unsigned int)(num_src *
  1120.          sizeof(struct srcfile *)));
  1121.       for (hashval = 0; hashval < DHSize; ++hashval)
  1122.          for (sfile = dhash[hashval]; sfile != NULL; sfile = sfile->next)
  1123.             sort_ary[num++] = sfile;
  1124.       qsort((char *)sort_ary, num, sizeof(struct srcfile *),
  1125.          (int (*)())src_cmp);
  1126.       }
  1127.  
  1128.    /*
  1129.     * For each source file with dependents, output the source file
  1130.     *  name followed by the list of dependent files. The list is
  1131.     *  terminated with "end".
  1132.     */
  1133.    for (i = 0; i < num; ++i) {
  1134.       sfile = sort_ary[i];
  1135.       if (sfile->dependents != NULL) {
  1136.          fprintf(db, "%-12s  ", sfile->name);
  1137.          line_left = prt_c_fl(db, sfile->dependents, MaxLine - 14);
  1138.          if (line_left - 4 < 0)
  1139.             fprintf(db, "\n            ");
  1140.          fprintf(db, "$end\n");
  1141.          }
  1142.       }
  1143.    fprintf(db, "\n$endsect\n");  /* end of dependency section */
  1144.    if (num_src > 0)
  1145.       free((char *)sort_ary);
  1146.    }
  1147.  
  1148. /*
  1149.  * src_cmp - compare srcfile structs; function used as an argument to qsort().
  1150.  */
  1151. static int src_cmp(p1, p2)
  1152. char *p1;
  1153. char *p2;
  1154.    {
  1155.    register struct srcfile *sp1;
  1156.    register struct srcfile *sp2;
  1157.  
  1158.    sp1 = *(struct srcfile **)p1;
  1159.    sp2 = *(struct srcfile **)p2;
  1160.    return strcmp(sp1->name, sp2->name);
  1161.    }
  1162.  
  1163. /*
  1164.  * prt_c_fl - print list of C files in reverse order.
  1165.  */
  1166. static int prt_c_fl(db, clst, line_left)
  1167. FILE *db;
  1168. struct cfile *clst;
  1169. int line_left;
  1170.    {
  1171.    int len;
  1172.  
  1173.    if (clst == NULL)
  1174.       return line_left;
  1175.    line_left = prt_c_fl(db, clst->next, line_left);
  1176.  
  1177.    /*
  1178.     * If this will exceed the line length, print a new-line and some
  1179.     *  leading white space.
  1180.     */
  1181.    len = strlen(clst->name) + 1;
  1182.    if (line_left - len < 0) {
  1183.       fprintf(db, "\n              ");
  1184.       line_left = MaxLine - 14;
  1185.       }
  1186.    fprintf(db, "%s ", clst->name);
  1187.    return line_left - len;
  1188.    }
  1189. #endif                    /* Rttx */
  1190.  
  1191. /*
  1192.  * full_lst - print a full list of all files produced by translations
  1193.  *  as represented in the dependencies section of the data base.
  1194.  */
  1195. novalue full_lst(fname)
  1196. char *fname;
  1197.    {
  1198.    unsigned hashval;
  1199.    struct srcfile *sfile;
  1200.    struct cfile *clst;
  1201.    struct fileparts *fp;
  1202.    FILE *f;
  1203.  
  1204.    f = fopen(fname, "w");
  1205.    if (f == NULL)
  1206.       err2("cannot open ", fname);
  1207.    for (hashval = 0; hashval < DHSize; ++hashval)
  1208.       for (sfile = dhash[hashval]; sfile != NULL; sfile = sfile->next)
  1209.          for (clst = sfile->dependents; clst != NULL; clst = clst->next) {
  1210.             /*
  1211.              * Remove the suffix from the name before printing.
  1212.              */
  1213.             fp = fparse(clst->name);
  1214.             fprintf(f, "%s\n", fp->name);
  1215.             }
  1216.    if (fclose(f) != 0)
  1217.       err2("cannot close ", fname);
  1218.    }
  1219.  
  1220. /*
  1221.  * impl_fnc - find or create implementation struct for function currently
  1222.  *  being parsed.
  1223.  */
  1224. novalue impl_fnc(name)
  1225. struct token *name;
  1226.    {
  1227.    /*
  1228.     * Set the global operation type for later use. If this is a
  1229.     *  new function update the number of them.
  1230.     */
  1231.    op_type = Function;
  1232.    num_fnc = set_impl(name, bhash, num_fnc, fnc_pre);
  1233.    }
  1234.  
  1235. /*
  1236.  * impl_key - find or create implementation struct for keyword currently
  1237.  *  being parsed.
  1238.  */
  1239. novalue impl_key(name)
  1240. struct token *name;
  1241.    {
  1242.    /*
  1243.     * Set the global operation type for later use. If this is a
  1244.     *  new keyword update the number of them.
  1245.     */
  1246.    op_type = Keyword;
  1247.    num_key = set_impl(name, khash, num_key, key_pre);
  1248.    }
  1249.  
  1250. /*
  1251.  * set_impl - lookup a function or keyword in a hash table and update the
  1252.  *  entry, creating the entry if needed.
  1253.  */
  1254. static int set_impl(name, tbl, num_impl, pre)
  1255. struct token *name;
  1256. struct implement **tbl;
  1257. int num_impl;
  1258. char *pre;
  1259.    {
  1260.    register struct implement *ptr;
  1261.    char *name_s;
  1262.    unsigned hashval;
  1263.  
  1264.    /*
  1265.     * we only need the operation name and not the entire token.
  1266.     */
  1267.    name_s = name->image;
  1268.    free_t(name);
  1269.  
  1270.    /*
  1271.     * If the operation is not in the hash table, put it there.
  1272.     */
  1273.    if ((ptr = db_ilkup(name_s, tbl)) == NULL) {
  1274.       ptr = NewStruct(implement);
  1275.       hashval = IHasher(name_s);
  1276.       ptr->blink = tbl[hashval];
  1277.       ptr->oper_typ = ((op_type == Function) ? 'F' : 'K');
  1278.       nxt_pre(ptr->prefix, pre, 2);    /* allocate a unique prefix */
  1279.       ptr->name = name_s;
  1280.       ptr->op = NULL;
  1281.       tbl[hashval] = ptr;
  1282.       ++num_impl;
  1283.       }
  1284.  
  1285.    cur_impl = ptr;   /* put entry in global variable for later access */
  1286.  
  1287.    /*
  1288.     * initialize the entry based on global information set during parsing.
  1289.     */
  1290.    set_prms(ptr);
  1291.    ptr->min_result = min_rs;
  1292.    ptr->max_result = max_rs;
  1293.    ptr->resume = rsm_rs;
  1294.    ptr->ret_flag = 0;
  1295.    if (comment == NULL)
  1296.       ptr->comment = "";
  1297.    else {
  1298.       ptr->comment = comment->image;
  1299.       free_t(comment);
  1300.       comment = NULL;
  1301.       }
  1302.    ptr->ntnds = 0;
  1303.    ptr->tnds = NULL;
  1304.    ptr->nvars = 0;
  1305.    ptr->vars = NULL;
  1306.    ptr->in_line = NULL;
  1307.    ptr->iconc_flgs = 0;
  1308.    return num_impl;
  1309.    }
  1310.  
  1311. /*
  1312.  * set_prms - set the parameter information of an implementation based on
  1313.  *   the params list constructed during parsing.
  1314.  */
  1315. static novalue set_prms(ptr)
  1316. struct implement *ptr;
  1317.    {
  1318.    struct sym_entry *sym;
  1319.    int nargs;
  1320.    int i;
  1321.  
  1322.    /*
  1323.     * Create an array of parameter flags for the operation. The flag
  1324.     * indicates the deref/underef and varargs status for each parameter.
  1325.     */
  1326.    if (params == NULL) {
  1327.       ptr->nargs = 0;
  1328.       ptr->arg_flgs = NULL;
  1329.       }
  1330.    else {
  1331.       /*
  1332.        * The parameters are in reverse order, so the number of the parameters
  1333.        *  can be determined by the number assigned to the first one on the
  1334.        *  list.
  1335.        */
  1336.       nargs = params->u.param_info.param_num + 1;
  1337.       ptr->nargs = nargs;
  1338.       ptr->arg_flgs = (int *)alloc((unsigned int)(sizeof(int) * nargs));
  1339.       for (i = 0; i < nargs; ++i)
  1340.          ptr->arg_flgs[i] = 0;
  1341.       for (sym = params; sym != NULL; sym = sym->u.param_info.next)
  1342.          ptr->arg_flgs[sym->u.param_info.param_num] |= sym->id_type;
  1343.       }
  1344.    }
  1345.  
  1346. /*
  1347.  * impl_op - find or create implementation struct for operator currently
  1348.  *  being parsed.
  1349.  */
  1350. novalue impl_op(op_sym, name)
  1351. struct token *op_sym;
  1352. struct token *name;
  1353.    {
  1354.    register struct implement *ptr;
  1355.    char *op;
  1356.    int nargs;
  1357.    unsigned hashval;
  1358.  
  1359.    /*
  1360.     * The operator symbol is needed but not the entire token.
  1361.     */
  1362.    op = op_sym->image;
  1363.    free_t(op_sym);
  1364.  
  1365.    /*
  1366.     * The parameters are in reverse order, so the number of the parameters
  1367.     *  can be determined by the number assigned to the first one on the
  1368.     *  list.
  1369.     */
  1370.    if (params == NULL)
  1371.       nargs = 0;
  1372.    else
  1373.       nargs = params->u.param_info.param_num + 1;
  1374.  
  1375.    /*
  1376.     * Locate the operator in the hash table; it must match both the
  1377.     *  operator symbol and the number of arguments. If the operator is
  1378.     *  not there, create an entry.
  1379.     */
  1380.    hashval = IHasher(op);
  1381.    ptr = ohash[hashval];
  1382.    while (ptr != NULL && (ptr->op != op || ptr->nargs != nargs))
  1383.       ptr = ptr->blink;
  1384.    if (ptr == NULL) {
  1385.       ptr = NewStruct(implement);
  1386.       ptr->blink = ohash[hashval];
  1387.       ptr->oper_typ = 'O';
  1388.       nxt_pre(ptr->prefix, op_pre, 2);   /* allocate a unique prefix */
  1389.       ptr->op = op;
  1390.       ohash[hashval] = ptr;
  1391.       ++num_op;
  1392.       }
  1393.  
  1394.    /* 
  1395.     * Put the entry and operation type in global variables for
  1396.     *  later access.
  1397.     */
  1398.    cur_impl = ptr;
  1399.    op_type = Operator;
  1400.  
  1401.    /*
  1402.     * initialize the entry based on global information set during parsing.
  1403.     */
  1404.    ptr->name = name->image;
  1405.    free_t(name);
  1406.    set_prms(ptr);
  1407.    ptr->min_result = min_rs;
  1408.    ptr->max_result = max_rs;
  1409.    ptr->resume = rsm_rs;
  1410.    ptr->ret_flag = 0;
  1411.    if (comment == NULL)
  1412.       ptr->comment = "";
  1413.    else {
  1414.       ptr->comment = comment->image;
  1415.       free_t(comment);
  1416.       comment = NULL;
  1417.       }
  1418.    ptr->ntnds = 0;
  1419.    ptr->tnds = NULL;
  1420.    ptr->nvars = 0;
  1421.    ptr->vars = NULL;
  1422.    ptr->in_line = NULL;
  1423.    ptr->iconc_flgs = 0;
  1424.    }
  1425.  
  1426. /*
  1427.  * set_r_seq - save result sequence information for updating the
  1428.  *  operation entry.
  1429.  */
  1430. novalue set_r_seq(min, max, resume)
  1431. long min;
  1432. long max;
  1433. int resume;
  1434.    {
  1435.    if (min == UnbndSeq)
  1436.       min = 0;
  1437.    min_rs = min;
  1438.    max_rs = max;
  1439.    rsm_rs = resume;
  1440.    }
  1441.  
  1442.